home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.003 / stk-3 / stk / 3.1 / STk / Image.stklos < prev    next >
Encoding:
Text File  |  1996-07-29  |  3.0 KB  |  93 lines
  1. ;;;;
  2. ;;;; I m a g e . s t k         --  The Tk4.0 image mechanism
  3. ;;;;
  4. ;;;; Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  5. ;;;; 
  6. ;;;; Permission to use, copy, and/or distribute this software and its
  7. ;;;; documentation for any purpose and without fee is hereby granted, provided
  8. ;;;; that both the above copyright notice and this permission notice appear in
  9. ;;;; all copies and derived works.  Fees for distribution or use of this
  10. ;;;; software or derived works may only be charged with express written
  11. ;;;; permission of the copyright holder.  
  12. ;;;; This software is provided ``as is'' without express or implied warranty.
  13. ;;;;
  14. ;;;;           Author: Erick Gallesio [eg@unice.fr]
  15. ;;;;    Creation date: 26-Jul-1995 11:23
  16. ;;;; Last file update: 13-Dec-1995 23:25
  17.  
  18. (require "Basics")
  19.  
  20. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  21. ;;;;
  22. ;;;; <Tk-image> class definition
  23. ;;;;
  24. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  25.  
  26. (define-class <Tk-Image> ()
  27.   ((Id      :getter Id)
  28.    (file    :accessor    file
  29.         :init-keyword    :file
  30.         :allocation    :tk-virtual)
  31.    (data    :accessor    image-data
  32.         :init-keyword    :data
  33.         :allocation    :tk-virtual))   
  34.   :metaclass <Tk-metaclass>)
  35.  
  36. (define-method initialize ((self <Tk-Image>) initargs)
  37.   (let ((tk-options (get-keyword :tk-options initargs '())))
  38.     (slot-set! self 'id (initialize-image self tk-options))
  39.     (next-method)))
  40.  
  41. ;;; Tk-write-object is called when a STklos object is passed to a Tk-command.
  42. ;;; By default, we do the same job as write; but if an object is a <Tk-Image>
  43. ;;; we will pass it its id. This method does this job.
  44. (define-method Tk-write-object((self <Tk-Image>) port)
  45.   (write (widget-name (slot-ref self 'id)) port))
  46.  
  47. ;;;
  48. ;;; Destroy
  49. ;;;
  50. (define-method destroy ((self <Tk-image>))
  51.   (Tk:image 'delete self))
  52.  
  53. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  54. ;;;;
  55. ;;;; <Bitmap-image> class definition
  56. ;;;;
  57. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  58.  
  59. (define-class <Bitmap-image> (<Tk-Image>)
  60.   ((background :accessor     background
  61.            :init-keyword    :background
  62.            :allocation    :tk-virtual)
  63.    (foreground :accessor     foreground
  64.            :init-keyword    :foreground
  65.            :allocation    :tk-virtual)
  66.    (mask-data  :accessor     mask-data
  67.            :init-keyword    :mask-data
  68.            :tk-name        maskdata
  69.            :allocation    :tk-virtual)
  70.    (mask-file  :accessor     mask-file
  71.            :init-keyword    :mask-file
  72.            :tk-name        maskfile
  73.            :allocation    :tk-virtual)))
  74.  
  75. (define-method initialize-image((self <Bitmap-image>) args)
  76.   (apply Tk:image 'create 'bitmap (gensym "img") args))
  77.  
  78. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  79. ;;;;
  80. ;;;; <Photo-image> class definition
  81. ;;;;
  82. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  83. (define-class <Photo-image> (<Tk-Image>)
  84.   ())
  85.  
  86. (define-method initialize-image((self <Photo-image>) args)
  87.   (apply Tk:image 'create 'photo (gensym "img") args))
  88.  
  89.  
  90.  
  91.  
  92. (provide "Image")
  93.